home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlstr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  13.1 KB  |  556 lines
  1. /* xlstr - xlisp string and character built-in functions */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* local definitions */
  10. #define fix(n)    cvfixnum((FIXTYPE)(n))
  11. #define TLEFT    1
  12. #define TRIGHT    2
  13.  
  14. /* external variables */
  15. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  16. extern LVAL true;
  17. extern char buf[];
  18.  
  19. /* getbounds - get the start and end bounds of a string */
  20. #ifdef ANSI
  21. static void getbounds(LVAL str, LVAL skey, LVAL ekey, int *pstart, int *pend)
  22. #else
  23. LOCAL VOID getbounds(str,skey,ekey,pstart,pend)
  24.   LVAL str,skey,ekey; int *pstart,*pend;
  25. #endif
  26. {
  27.     LVAL arg;
  28.     int len;
  29.  
  30.     /* get the length of the string */
  31.     len = getslength(str) - 1;
  32.  
  33.     /* get the starting index */
  34.     if (xlgkfixnum(skey,&arg)) {
  35.         *pstart = (int)getfixnum(arg);
  36.         if (*pstart < 0 || *pstart > len)
  37.             xlerror("string index out of bounds",arg);
  38.     }
  39.     else
  40.         *pstart = 0;
  41.  
  42.     /* get the ending index */
  43. #ifdef COMMONLISP        /* allow NIL to mean "to end of string" */
  44.     if (xlgetkeyarg(ekey, &arg) && arg != NIL) {
  45.         if (!fixp(arg)) xlbadtype(arg);
  46. #else
  47.     if (xlgkfixnum(ekey,&arg)) {
  48. #endif
  49.         *pend = (int)getfixnum(arg);
  50.         if (*pend < 0 || *pend > len)
  51.             xlerror("string index out of bounds",arg);
  52.     }
  53.     else
  54.         *pend = len;
  55.  
  56.     /* make sure the start is less than or equal to the end */
  57.     if (*pstart > *pend)
  58.         xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
  59. }
  60.  
  61. /* strcompare - compare strings */
  62. #ifdef ANSI
  63. static LVAL strcompare(int fcn, int icase)
  64. #else
  65. LOCAL LVAL strcompare(fcn,icase)
  66.   int fcn,icase;
  67. #endif
  68. {
  69.     int start1,end1,start2,end2,ch1,ch2;
  70.     char *p1,*p2;
  71.     LVAL str1,str2;
  72.  
  73.     /* get the strings */
  74.     str1 = xlgastrorsym();
  75.     str2 = xlgastrorsym();
  76.  
  77.     /* get the substring specifiers */
  78.     getbounds(str1,k_1start,k_1end,&start1,&end1);
  79.     getbounds(str2,k_2start,k_2end,&start2,&end2);
  80.  
  81.     /* setup the string pointers */
  82.     p1 = &getstring(str1)[start1];
  83.     p2 = &getstring(str2)[start2];
  84.  
  85.     /* compare the strings */
  86.     for (; start1 < end1 && start2 < end2; ++start1,++start2) {
  87.         ch1 = *p1++;
  88.         ch2 = *p2++;
  89.         if (icase) {
  90.             if (isupper(ch1)) ch1 = tolower(ch1);
  91.             if (isupper(ch2)) ch2 = tolower(ch2);
  92.         }
  93.         if (ch1 != ch2)
  94.             switch (fcn) {
  95.             case '<':    return (ch1 < ch2 ? fix(start1) : NIL);
  96.             case 'L':    return (ch1 <= ch2 ? fix(start1) : NIL);
  97.             case '=':    return (NIL);
  98.             case '#':    return (fix(start1));
  99.             case 'G':    return (ch1 >= ch2 ? fix(start1) : NIL);
  100.             case '>':    return (ch1 > ch2 ? fix(start1) : NIL);
  101.             }
  102.     }
  103.  
  104.     /* check the termination condition */
  105.     switch (fcn) {
  106.     case '<':    return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
  107.     case 'L':    return (start1 >= end1 ? fix(start1) : NIL);
  108.     case '=':    return (start1 >= end1 && start2 >= end2 ? true : NIL);
  109.     case '#':    return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
  110.     case 'G':    return (start2 >= end2 ? fix(start1) : NIL);
  111.     case '>':    return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
  112.     }
  113.     return (NIL);    /* avoid compiler warning */
  114. }
  115.  
  116. /* string comparision functions */
  117. LVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */
  118. LVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */
  119. LVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */
  120. LVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */
  121. LVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */
  122. LVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */
  123.  
  124. /* string comparison functions (not case sensitive) */
  125. LVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */
  126. LVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */
  127. LVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */
  128. LVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */
  129. LVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */
  130. LVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */
  131.  
  132. /* changecase - change case */
  133. #ifdef ANSI
  134. static LVAL changecase(int fcn, int destructive)
  135. #else
  136. LOCAL LVAL changecase(fcn,destructive)
  137.   int fcn,destructive;
  138. #endif
  139. {
  140.     char *srcp,*dstp;
  141.     int start,end,len,ch,i;
  142.     LVAL src,dst;
  143.  
  144.     /* get the string */
  145. #ifdef COMMONLISP
  146.     src = (destructive? xlgastring() : xlgastrorsym());
  147. #else
  148.     src = xlgastring();
  149. #endif
  150.  
  151.     /* get the substring specifiers */
  152.     getbounds(src,k_start,k_end,&start,&end);
  153.     len = getslength(src) - 1;
  154.  
  155.     /* make a destination string */
  156.     dst = (destructive ? src : newstring(len+1));
  157.  
  158.     /* setup the string pointers */
  159.     srcp = getstring(src);
  160.     dstp = getstring(dst);
  161.  
  162.     /* copy the source to the destination */
  163.     for (i = 0; i < len; ++i) {
  164.         ch = *srcp++;
  165.         if (i >= start && i < end)
  166.             switch (fcn) {
  167.             case 'U':    if (islower(ch)) ch = toupper(ch); break;
  168.             case 'D':    if (isupper(ch)) ch = tolower(ch); break;
  169.             }
  170.         *dstp++ = ch;
  171.     }
  172.     *dstp = '\0';
  173.  
  174.     /* return the new string */
  175.     return (dst);
  176. }
  177.  
  178. /* case conversion functions */
  179. LVAL xupcase()     { return (changecase('U',FALSE)); }
  180. LVAL xdowncase() { return (changecase('D',FALSE)); }
  181.  
  182. /* destructive case conversion functions */
  183. LVAL xnupcase()      { return (changecase('U',TRUE)); }
  184. LVAL xndowncase() { return (changecase('D',TRUE)); }
  185.  
  186. /* inbag - test if a character is in a bag */
  187. #ifdef ANSI
  188. static int inbag(unsigned int ch, LVAL bag)
  189. #else
  190. LOCAL int inbag(ch,bag)
  191.   unsigned int ch; LVAL bag;
  192. #endif
  193. {
  194.     char *p;
  195.     for (p = getstring(bag); *p != '\0'; ++p)
  196.         if (*p == ch)
  197.             return (TRUE);
  198.     return (FALSE);
  199. }
  200.  
  201. /* trim - trim character from a string */
  202. #ifdef ANSI
  203. static LVAL trim(int fcn)
  204. #else
  205. LOCAL LVAL trim(fcn)
  206.   int fcn;
  207. #endif
  208. {
  209.     char *leftp,*rightp,*dstp;
  210.     LVAL bag,src,dst;
  211.  
  212.     /* get the bag and the string */
  213.     bag = xlgastrorsym();
  214.     src = xlgastrorsym();
  215.     xllastarg();
  216.  
  217.     /* setup the string pointers */
  218.     leftp = getstring(src);
  219.     rightp = leftp + getslength(src) - 2;
  220.  
  221.     /* trim leading characters */
  222.     if (fcn & TLEFT)
  223.         while (leftp <= rightp && inbag(*leftp,bag))
  224.             ++leftp;
  225.  
  226.     /* trim character from the right */
  227.     if (fcn & TRIGHT)
  228.         while (rightp >= leftp && inbag(*rightp,bag))
  229.             --rightp;
  230.  
  231.     /* make a destination string and setup the pointer */
  232.     dst = newstring((int)(rightp-leftp+2));
  233.     dstp = getstring(dst);
  234.  
  235.     /* copy the source to the destination */
  236.     while (leftp <= rightp)
  237.         *dstp++ = *leftp++;
  238.     *dstp = '\0';
  239.  
  240.     /* return the new string */
  241.     return (dst);
  242. }
  243.  
  244. /* trim functions */
  245. LVAL xtrim()      { return (trim(TLEFT|TRIGHT)); }
  246. LVAL xlefttrim()  { return (trim(TLEFT)); }
  247. LVAL xrighttrim() { return (trim(TRIGHT)); }
  248.  
  249. #ifndef COMMONLISP        /* revised version is CONCATENATE, in xlseq.c */
  250. /* xstrcat - concatenate a bunch of strings */
  251. LVAL xstrcat()
  252. {
  253.     LVAL *saveargv,tmp,val;
  254.     char *str;
  255.     int saveargc,len;
  256.  
  257.     /* save the argument list */
  258.     saveargv = xlargv;
  259.     saveargc = xlargc;
  260.  
  261.     /* find the length of the new string */
  262.     for (len = 0; moreargs(); ) {
  263.         tmp = xlgastring();
  264.         len += (int)getslength(tmp) - 1;
  265.         if (len < 0) xlerror("string too long",tmp);
  266.     }
  267.  
  268.     /* create the result string */
  269.     val = newstring(len+1);
  270.     str = getstring(val);
  271.  
  272.     /* restore the argument list */
  273.     xlargv = saveargv;
  274.     xlargc = saveargc;
  275.     
  276.     /* combine the strings */
  277.     for (*str = '\0'; moreargs(); ) {
  278.         tmp = nextarg();
  279.         strcat(str,getstring(tmp));
  280.     }
  281.  
  282.     /* return the new string */
  283.     return (val);
  284. }
  285.  
  286. /* xsubseq - return a subsequence */
  287. /* New correct version in xlseq.c */
  288. LVAL xsubseq()
  289. {
  290.     char *srcp,*dstp;
  291.     int start,end,len;
  292.     LVAL src,dst;
  293.  
  294.     /* get string and starting and ending positions */
  295.     src = xlgastring();
  296.  
  297.     /* get the starting position */
  298.     dst = xlgafixnum(); start = (int)getfixnum(dst);
  299.     if (start < 0 || start > getslength(src) - 1)
  300.         xlerror("string index out of bounds",dst);
  301.  
  302.     /* get the ending position */
  303.     if (moreargs()) {
  304.         dst = xlgafixnum(); end = (int)getfixnum(dst);
  305.         if (end < 0 || end > getslength(src) - 1)
  306.             xlerror("string index out of bounds",dst);
  307.     }
  308.     else
  309.         end = getslength(src) - 1;
  310.     xllastarg();
  311.  
  312.     /* setup the source pointer */
  313.     srcp = getstring(src) + start;
  314.     len = end - start;
  315.  
  316.     /* make a destination string and setup the pointer */
  317.     dst = newstring(len+1);
  318.     dstp = getstring(dst);
  319.  
  320.     /* copy the source to the destination */
  321.     while (--len >= 0)
  322.         *dstp++ = *srcp++;
  323.     *dstp = '\0';
  324.  
  325.     /* return the substring */
  326.     return (dst);
  327. }
  328.  
  329. #endif
  330.  
  331. /* xstring - return a string consisting of a single character */
  332. LVAL xstring()
  333. {
  334.     LVAL arg;
  335.  
  336.     /* get the argument */
  337.     arg = xlgetarg();
  338.     xllastarg();
  339.  
  340.     /* make sure its not NIL */
  341.     if (null(arg))
  342.         xlbadtype(arg);
  343.  
  344.     /* check the argument type */
  345.     switch (ntype(arg)) {
  346.     case STRING:
  347.         return (arg);
  348.     case SYMBOL:
  349.         return (getpname(arg));
  350.     case CHAR:
  351.         buf[0] = (int)getchcode(arg);
  352.         buf[1] = '\0';
  353.         return (cvstring(buf));
  354.     case FIXNUM:
  355.         buf[0] = getfixnum(arg);
  356.         buf[1] = '\0';
  357.         return (cvstring(buf));
  358.     default:
  359.         xlbadtype(arg);
  360.         return (NIL);    /* avoid compiler warning */
  361.     }
  362. }
  363.  
  364. /* xchar - extract a character from a string */
  365. LVAL xchar()
  366. {
  367.     LVAL str,num;
  368.     int n;
  369.  
  370.     /* get the string and the index */
  371.     str = xlgastring();
  372.     num = xlgafixnum();
  373.     xllastarg();
  374.  
  375.     /* range check the index */
  376.     if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
  377.         xlerror("index out of range",num);
  378.  
  379.     /* return the character */
  380.     return (cvchar(getstringch(str,n)));
  381. }
  382.  
  383. /* xcharint - convert a character to an integer */
  384. LVAL xcharint()
  385. {
  386.     LVAL arg;
  387.     arg = xlgachar();
  388.     xllastarg();
  389.     return (cvfixnum((FIXTYPE)getchcode(arg)));
  390. }
  391.  
  392. /* xintchar - convert an integer to a character */
  393. LVAL xintchar()
  394. {
  395.     LVAL arg;
  396.     arg = xlgafixnum();
  397.     xllastarg();
  398.     return (cvchar((int)getfixnum(arg)));
  399. }
  400.  
  401. /* xcharcode - built-in function 'char-code' */
  402. /* TAA mod so that result is 7 bit ascii code */
  403. LVAL xcharcode()
  404. {
  405.     int ch;
  406.     ch = 0x7f  & getchcode(xlgachar());
  407.     xllastarg();
  408.     return (cvfixnum((FIXTYPE)ch));
  409. }
  410.  
  411. /* xcodechar - built-in function 'code-char' */
  412. /* like int-char except range must be 0-127 */
  413. LVAL xcodechar()
  414. {
  415.     LVAL arg;
  416.     FIXTYPE ch;
  417.     arg = xlgafixnum(); ch = getfixnum(arg);
  418.     xllastarg();
  419.     return (ch >= 0 && ch <= 127 ? cvchar((int)ch) : NIL);
  420. }
  421.  
  422. /* xuppercasep - built-in function 'upper-case-p' */
  423. LVAL xuppercasep()
  424. {
  425.     int ch;
  426.     ch = getchcode(xlgachar());
  427.     xllastarg();
  428.     return (isupper(ch) ? true : NIL);
  429. }
  430.  
  431. /* xlowercasep - built-in function 'lower-case-p' */
  432. LVAL xlowercasep()
  433. {
  434.     int ch;
  435.     ch = getchcode(xlgachar());
  436.     xllastarg();
  437.     return (islower(ch) ? true : NIL);
  438. }
  439.  
  440. /* xbothcasep - built-in function 'both-case-p' */
  441. LVAL xbothcasep()
  442. {
  443.     int ch;
  444.     ch = getchcode(xlgachar());
  445.     xllastarg();
  446.     return (isupper(ch) || islower(ch) ? true : NIL);
  447. }
  448.  
  449. /* xdigitp - built-in function 'digit-char-p' */
  450. LVAL xdigitp()
  451. {
  452.     int ch;
  453.     ch = getchcode(xlgachar());
  454.     xllastarg();
  455.     return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
  456. }
  457.  
  458. /* xchupcase - built-in function 'char-upcase' */
  459. LVAL xchupcase()
  460. {
  461.     LVAL arg;
  462.     int ch;
  463.     arg = xlgachar(); ch = getchcode(arg);
  464.     xllastarg();
  465.     return (islower(ch) ? cvchar(toupper(ch)) : arg);
  466. }
  467.  
  468. /* xchdowncase - built-in function 'char-downcase' */
  469. LVAL xchdowncase()
  470. {
  471.     LVAL arg;
  472.     int ch;
  473.     arg = xlgachar(); ch = getchcode(arg);
  474.     xllastarg();
  475.     return (isupper(ch) ? cvchar(tolower(ch)) : arg);
  476. }
  477.  
  478. /* xdigitchar - built-in function 'digit-char' */
  479. LVAL xdigitchar()
  480. {
  481.     LVAL arg;
  482.     FIXTYPE n;
  483.     arg = xlgafixnum(); n = getfixnum(arg);
  484.     xllastarg();
  485.     return (n >= 0 && n <= 9 ? cvchar((int)n + '0') : NIL);
  486. }
  487.  
  488. /* xalphanumericp - built-in function 'alphanumericp' */
  489. LVAL xalphanumericp()
  490. {
  491.     int ch;
  492.     ch = getchcode(xlgachar());
  493.     xllastarg();
  494.     return (isupper(ch) || islower(ch) || isdigit(ch) ? true : NIL);
  495. }
  496.  
  497. /* chrcompare - compare characters */
  498. #ifdef ANSI
  499. static LVAL chrcompare(int fcn, int icase)
  500. #else
  501. LOCAL LVAL chrcompare(fcn,icase)
  502.   int fcn,icase;
  503. #endif
  504. {
  505.     int ch1,ch2,icmp;
  506.     LVAL arg;
  507.     
  508.     /* get the characters */
  509.     arg = xlgachar(); ch1 = getchcode(arg);
  510.  
  511.     /* convert to lowercase if case insensitive */
  512.     if (icase && isupper(ch1))
  513.         ch1 = tolower(ch1);
  514.  
  515.     /* handle each remaining argument */
  516.     for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
  517.  
  518.         /* get the next argument */
  519.         arg = xlgachar(); ch2 = getchcode(arg);
  520.  
  521.         /* convert to lowercase if case insensitive */
  522.         if (icase && isupper(ch2))
  523.             ch2 = tolower(ch2);
  524.  
  525.         /* compare the characters */
  526.         switch (fcn) {
  527.         case '<':        icmp = (ch1 < ch2); break;
  528.         case 'L':        icmp = (ch1 <= ch2); break;
  529.         case '=':        icmp = (ch1 == ch2); break;
  530.         case '#':        icmp = (ch1 != ch2); break;
  531.         case 'G':        icmp = (ch1 >= ch2); break;
  532.         case '>':        icmp = (ch1 > ch2); break;
  533.         }
  534.     }
  535.  
  536.     /* return the result */
  537.     return (icmp ? true : NIL);
  538. }
  539.  
  540. /* character comparision functions */
  541. LVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char< */
  542. LVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<= */
  543. LVAL xchreql() { return (chrcompare('=',FALSE)); } /* char= */
  544. LVAL xchrneq() { return (chrcompare('#',FALSE)); } /* char/= */
  545. LVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>= */
  546. LVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char> */
  547.  
  548. /* character comparision functions (case insensitive) */
  549. LVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-lessp */
  550. LVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
  551. LVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-equalp */
  552. LVAL xchrineq() { return (chrcompare('#',TRUE)); } /* char-not-equalp */
  553. LVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-not-lessp */
  554. LVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-greaterp */
  555.  
  556.